home *** CD-ROM | disk | FTP | other *** search
/ Sprite 1984 - 1993 / Sprite 1984 - 1993.iso / src / lib / tcl / dist / tclCmdIL.c < prev    next >
Encoding:
C/C++ Source or Header  |  1992-03-07  |  28.6 KB  |  1,139 lines
  1. /* 
  2.  * tclCmdIL.c --
  3.  *
  4.  *    This file contains the top-level command routines for most of
  5.  *    the Tcl built-in commands whose names begin with the letters
  6.  *    I through L.  It contains only commands in the generic core
  7.  *    (i.e. those that don't depend much upon UNIX facilities).
  8.  *
  9.  * Copyright 1987-1991 Regents of the University of California
  10.  * Permission to use, copy, modify, and distribute this
  11.  * software and its documentation for any purpose and without
  12.  * fee is hereby granted, provided that the above copyright
  13.  * notice appear in all copies.  The University of California
  14.  * makes no representations about the suitability of this
  15.  * software for any purpose.  It is provided "as is" without
  16.  * express or implied warranty.
  17.  */
  18.  
  19. #ifndef lint
  20. static char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclCmdIL.c,v 1.84 91/12/06 10:42:36 ouster Exp $ SPRITE (Berkeley)";
  21. #endif
  22.  
  23. #include "tclInt.h"
  24.  
  25. /*
  26.  * Forward declarations for procedures defined in this file:
  27.  */
  28.  
  29. static int        SortCompareProc _ANSI_ARGS_((CONST VOID *first,
  30.                 CONST VOID *second));
  31.  
  32. /*
  33.  *----------------------------------------------------------------------
  34.  *
  35.  * Tcl_IfCmd --
  36.  *
  37.  *    This procedure is invoked to process the "if" Tcl command.
  38.  *    See the user documentation for details on what it does.
  39.  *
  40.  * Results:
  41.  *    A standard Tcl result.
  42.  *
  43.  * Side effects:
  44.  *    See the user documentation.
  45.  *
  46.  *----------------------------------------------------------------------
  47.  */
  48.  
  49.     /* ARGSUSED */
  50. int
  51. Tcl_IfCmd(dummy, interp, argc, argv)
  52.     ClientData dummy;            /* Not used. */
  53.     Tcl_Interp *interp;            /* Current interpreter. */
  54.     int argc;                /* Number of arguments. */
  55.     char **argv;            /* Argument strings. */
  56. {
  57.     char *condition, *ifPart, *elsePart, *cmd, *name;
  58.     char *clause;
  59.     int result, value;
  60.  
  61.     name = argv[0];
  62.     if (argc < 3) {
  63.     ifSyntax:
  64.     Tcl_AppendResult(interp, "wrong # args: should be \"", name,
  65.         " bool ?then? command ?else? ?command?\"", (char *) NULL);
  66.     return TCL_ERROR;
  67.     }
  68.     condition = argv[1];
  69.     argc -= 2;
  70.     argv += 2;
  71.     if ((**argv == 't') && (strncmp(*argv, "then", strlen(*argv)) == 0)) {
  72.     argc--;
  73.     argv++;
  74.     }
  75.     if (argc < 1) {
  76.     goto ifSyntax;
  77.     }
  78.     ifPart = *argv;
  79.     argv++;
  80.     argc--;
  81.     if (argc == 0) {
  82.     elsePart = "";
  83.     } else {
  84.     if ((**argv == 'e') && (strncmp(*argv, "else", strlen(*argv)) == 0)) {
  85.         argc--;
  86.         argv++;
  87.     }
  88.     if (argc != 1) {
  89.         goto ifSyntax;
  90.     }
  91.     elsePart = *argv;
  92.     }
  93.  
  94.     cmd = ifPart;
  95.     clause = "\"then\" clause";
  96.     result = Tcl_ExprBoolean(interp, condition, &value);
  97.     if (result != TCL_OK) {
  98.     if (result == TCL_ERROR) {
  99.         char msg[60];
  100.         sprintf(msg, "\n    (\"if\" test line %d)", interp->errorLine);
  101.         Tcl_AddErrorInfo(interp, msg);
  102.     }
  103.     return result;
  104.     }
  105.     if (value == 0) {
  106.     cmd = elsePart;
  107.     clause = "\"else\" clause";
  108.     }
  109.     if (*cmd == 0) {
  110.     return TCL_OK;
  111.     }
  112.     result = Tcl_Eval(interp, cmd, 0, (char **) NULL);
  113.     if (result == TCL_ERROR) {
  114.     char msg[60];
  115.     sprintf(msg, "\n    (%s line %d)", clause, interp->errorLine);
  116.     Tcl_AddErrorInfo(interp, msg);
  117.     }
  118.     return result;
  119. }
  120.  
  121. /*
  122.  *----------------------------------------------------------------------
  123.  *
  124.  * Tcl_IncrCmd --
  125.  *
  126.  *    This procedure is invoked to process the "incr" Tcl command.
  127.  *    See the user documentation for details on what it does.
  128.  *
  129.  * Results:
  130.  *    A standard Tcl result.
  131.  *
  132.  * Side effects:
  133.  *    See the user documentation.
  134.  *
  135.  *----------------------------------------------------------------------
  136.  */
  137.  
  138.     /* ARGSUSED */
  139. int
  140. Tcl_IncrCmd(dummy, interp, argc, argv)
  141.     ClientData dummy;            /* Not used. */
  142.     Tcl_Interp *interp;            /* Current interpreter. */
  143.     int argc;                /* Number of arguments. */
  144.     char **argv;            /* Argument strings. */
  145. {
  146.     int value;
  147.     char *oldString, *result;
  148.     char newString[30];
  149.  
  150.     if ((argc != 2) && (argc != 3)) {
  151.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  152.         " varName ?increment?\"", (char *) NULL);
  153.     return TCL_ERROR;
  154.     }
  155.  
  156.     oldString = Tcl_GetVar(interp, argv[1], TCL_LEAVE_ERR_MSG);
  157.     if (oldString == NULL) {
  158.     return TCL_ERROR;
  159.     }
  160.     if (Tcl_GetInt(interp, oldString, &value) != TCL_OK) {
  161.     Tcl_AddErrorInfo(interp,
  162.         "\n    (reading value of variable to increment)");
  163.     return TCL_ERROR;
  164.     }
  165.     if (argc == 2) {
  166.     value += 1;
  167.     } else {
  168.     int increment;
  169.  
  170.     if (Tcl_GetInt(interp, argv[2], &increment) != TCL_OK) {
  171.         Tcl_AddErrorInfo(interp,
  172.             "\n    (reading increment)");
  173.         return TCL_ERROR;
  174.     }
  175.     value += increment;
  176.     }
  177.     sprintf(newString, "%d", value);
  178.     result = Tcl_SetVar(interp, argv[1], newString, TCL_LEAVE_ERR_MSG);
  179.     if (result == NULL) {
  180.     return TCL_ERROR;
  181.     }
  182.     interp->result = result;
  183.     return TCL_OK; 
  184. }
  185.  
  186. /*
  187.  *----------------------------------------------------------------------
  188.  *
  189.  * Tcl_InfoCmd --
  190.  *
  191.  *    This procedure is invoked to process the "info" Tcl command.
  192.  *    See the user documentation for details on what it does.
  193.  *
  194.  * Results:
  195.  *    A standard Tcl result.
  196.  *
  197.  * Side effects:
  198.  *    See the user documentation.
  199.  *
  200.  *----------------------------------------------------------------------
  201.  */
  202.  
  203.     /* ARGSUSED */
  204. int
  205. Tcl_InfoCmd(dummy, interp, argc, argv)
  206.     ClientData dummy;            /* Not used. */
  207.     Tcl_Interp *interp;            /* Current interpreter. */
  208.     int argc;                /* Number of arguments. */
  209.     char **argv;            /* Argument strings. */
  210. {
  211.     register Interp *iPtr = (Interp *) interp;
  212.     int length;
  213.     char c;
  214.     Arg *argPtr;
  215.     Proc *procPtr;
  216.     Var *varPtr;
  217.     Command *cmdPtr;
  218.     Tcl_HashEntry *hPtr;
  219.     Tcl_HashSearch search;
  220.  
  221.     if (argc < 2) {
  222.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  223.         " option ?arg arg ...?\"", (char *) NULL);
  224.     return TCL_ERROR;
  225.     }
  226.     c = argv[1][0];
  227.     length = strlen(argv[1]);
  228.     if ((c == 'a') && (strncmp(argv[1], "args", length)) == 0) {
  229.     if (argc != 3) {
  230.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  231.             argv[0], " args procname\"", (char *) NULL);
  232.         return TCL_ERROR;
  233.     }
  234.     procPtr = TclFindProc(iPtr, argv[2]);
  235.     if (procPtr == NULL) {
  236.         infoNoSuchProc:
  237.         Tcl_AppendResult(interp, "\"", argv[2],
  238.             "\" isn't a procedure", (char *) NULL);
  239.         return TCL_ERROR;
  240.     }
  241.     for (argPtr = procPtr->argPtr; argPtr != NULL;
  242.         argPtr = argPtr->nextPtr) {
  243.         Tcl_AppendElement(interp, argPtr->name, 0);
  244.     }
  245.     return TCL_OK;
  246.     } else if ((c == 'b') && (strncmp(argv[1], "body", length)) == 0) {
  247.     if (argc != 3) {
  248.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  249.             " body procname\"", (char *) NULL);
  250.         return TCL_ERROR;
  251.     }
  252.     procPtr = TclFindProc(iPtr, argv[2]);
  253.     if (procPtr == NULL) {
  254.         goto infoNoSuchProc;
  255.     }
  256.     iPtr->result = procPtr->command;
  257.     return TCL_OK;
  258.     } else if ((c == 'c') && (strncmp(argv[1], "cmdcount", length) == 0)
  259.         && (length >= 2)) {
  260.     if (argc != 2) {
  261.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  262.             " cmdcount\"", (char *) NULL);
  263.         return TCL_ERROR;
  264.     }
  265.     sprintf(iPtr->result, "%d", iPtr->cmdCount);
  266.     return TCL_OK;
  267.     } else if ((c == 'c') && (strncmp(argv[1], "commands", length) == 0)
  268.         && (length >= 2)){
  269.     if (argc > 3) {
  270.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  271.             " commands [pattern]\"", (char *) NULL);
  272.         return TCL_ERROR;
  273.     }
  274.     for (hPtr = Tcl_FirstHashEntry(&iPtr->commandTable, &search);
  275.         hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
  276.         char *name = Tcl_GetHashKey(&iPtr->commandTable, hPtr);
  277.         if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) {
  278.         continue;
  279.         }
  280.         Tcl_AppendElement(interp, name, 0);
  281.     }
  282.     return TCL_OK;
  283.     } else if ((c == 'd') && (strncmp(argv[1], "default", length)) == 0) {
  284.     if (argc != 5) {
  285.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  286.             argv[0], " default procname arg varname\"",
  287.             (char *) NULL);
  288.         return TCL_ERROR;
  289.     }
  290.     procPtr = TclFindProc(iPtr, argv[2]);
  291.     if (procPtr == NULL) {
  292.         goto infoNoSuchProc;
  293.     }
  294.     for (argPtr = procPtr->argPtr; ; argPtr = argPtr->nextPtr) {
  295.         if (argPtr == NULL) {
  296.         Tcl_AppendResult(interp, "procedure \"", argv[2],
  297.             "\" doesn't have an argument \"", argv[3],
  298.             "\"", (char *) NULL);
  299.         return TCL_ERROR;
  300.         }
  301.         if (strcmp(argv[3], argPtr->name) == 0) {
  302.         if (argPtr->defValue != NULL) {
  303.             if (Tcl_SetVar((Tcl_Interp *) iPtr, argv[4],
  304.                 argPtr->defValue, 0) == NULL) {
  305.             defStoreError:
  306.             Tcl_AppendResult(interp,
  307.                 "couldn't store default value in variable \"",
  308.                 argv[4], "\"", (char *) NULL);
  309.             return TCL_ERROR;
  310.             }
  311.             iPtr->result = "1";
  312.         } else {
  313.             if (Tcl_SetVar((Tcl_Interp *) iPtr, argv[4], "", 0)
  314.                 == NULL) {
  315.             goto defStoreError;
  316.             }
  317.             iPtr->result = "0";
  318.         }
  319.         return TCL_OK;
  320.         }
  321.     }
  322.     } else if ((c == 'e') && (strncmp(argv[1], "exists", length) == 0)) {
  323.     char *p;
  324.     if (argc != 3) {
  325.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  326.             " exists varName\"", (char *) NULL);
  327.         return TCL_ERROR;
  328.     }
  329.     p = Tcl_GetVar((Tcl_Interp *) iPtr, argv[2], 0);
  330.  
  331.     /*
  332.      * The code below handles the special case where the name is for
  333.      * an array:  Tcl_GetVar will reject this since you can't read
  334.      * an array variable without an index.
  335.      */
  336.  
  337.     if (p == NULL) {
  338.         Tcl_HashEntry *hPtr;
  339.         Var *varPtr;
  340.  
  341.         if (strchr(argv[2], '(') != NULL) {
  342.         noVar:
  343.         iPtr->result = "0";
  344.         return TCL_OK;
  345.         }
  346.         if (iPtr->varFramePtr == NULL) {
  347.         hPtr = Tcl_FindHashEntry(&iPtr->globalTable, argv[2]);
  348.         } else {
  349.         hPtr = Tcl_FindHashEntry(&iPtr->varFramePtr->varTable, argv[2]);
  350.         }
  351.         if (hPtr == NULL) {
  352.         goto noVar;
  353.         }
  354.         varPtr = (Var *) Tcl_GetHashValue(hPtr);
  355.         if (varPtr->flags & VAR_UPVAR) {
  356.         varPtr = (Var *) Tcl_GetHashValue(varPtr->value.upvarPtr);
  357.         }
  358.         if (!(varPtr->flags & VAR_ARRAY)) {
  359.         goto noVar;
  360.         }
  361.     }
  362.     iPtr->result = "1";
  363.     return TCL_OK;
  364.     } else if ((c == 'g') && (strncmp(argv[1], "globals", length) == 0)) {
  365.     char *name;
  366.  
  367.     if (argc > 3) {
  368.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  369.             " globals [pattern]\"", (char *) NULL);
  370.         return TCL_ERROR;
  371.     }
  372.     for (hPtr = Tcl_FirstHashEntry(&iPtr->globalTable, &search);
  373.         hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
  374.         varPtr = (Var *) Tcl_GetHashValue(hPtr);
  375.         if (varPtr->flags & VAR_UNDEFINED) {
  376.         continue;
  377.         }
  378.         name = Tcl_GetHashKey(&iPtr->globalTable, hPtr);
  379.         if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) {
  380.         continue;
  381.         }
  382.         Tcl_AppendElement(interp, name, 0);
  383.     }
  384.     return TCL_OK;
  385.     } else if ((c == 'l') && (strncmp(argv[1], "level", length) == 0)
  386.         && (length >= 2)) {
  387.     if (argc == 2) {
  388.         if (iPtr->varFramePtr == NULL) {
  389.         iPtr->result = "0";
  390.         } else {
  391.         sprintf(iPtr->result, "%d", iPtr->varFramePtr->level);
  392.         }
  393.         return TCL_OK;
  394.     } else if (argc == 3) {
  395.         int level;
  396.         CallFrame *framePtr;
  397.  
  398.         if (Tcl_GetInt(interp, argv[2], &level) != TCL_OK) {
  399.         return TCL_ERROR;
  400.         }
  401.         if (level <= 0) {
  402.         if (iPtr->varFramePtr == NULL) {
  403.             levelError:
  404.             Tcl_AppendResult(interp, "bad level \"", argv[2],
  405.                 "\"", (char *) NULL);
  406.             return TCL_ERROR;
  407.         }
  408.         level += iPtr->varFramePtr->level;
  409.         }
  410.         for (framePtr = iPtr->varFramePtr; framePtr != NULL;
  411.             framePtr = framePtr->callerVarPtr) {
  412.         if (framePtr->level == level) {
  413.             break;
  414.         }
  415.         }
  416.         if (framePtr == NULL) {
  417.         goto levelError;
  418.         }
  419.         iPtr->result = Tcl_Merge(framePtr->argc, framePtr->argv);
  420.         iPtr->freeProc = (Tcl_FreeProc *) free;
  421.         return TCL_OK;
  422.     }
  423.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  424.         " level [number]\"", (char *) NULL);
  425.     return TCL_ERROR;
  426.     } else if ((c == 'l') && (strncmp(argv[1], "library", length) == 0)
  427.         && (length >= 2)) {
  428.     if (argc != 2) {
  429.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  430.             " library\"", (char *) NULL);
  431.         return TCL_ERROR;
  432.     }
  433. #ifdef TCL_LIBRARY
  434.     interp->result = TCL_LIBRARY;
  435.     return TCL_OK;
  436. #else
  437.     interp->result = "there is no Tcl library at this installation";
  438.     return TCL_ERROR;
  439. #endif
  440.     } else if ((c == 'l') && (strncmp(argv[1], "locals", length) == 0)
  441.         && (length >= 2)) {
  442.     char *name;
  443.  
  444.     if (argc > 3) {
  445.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  446.             " locals [pattern]\"", (char *) NULL);
  447.         return TCL_ERROR;
  448.     }
  449.     if (iPtr->varFramePtr == NULL) {
  450.         return TCL_OK;
  451.     }
  452.     for (hPtr = Tcl_FirstHashEntry(&iPtr->varFramePtr->varTable, &search);
  453.         hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
  454.         varPtr = (Var *) Tcl_GetHashValue(hPtr);
  455.         if (varPtr->flags & (VAR_UNDEFINED|VAR_UPVAR)) {
  456.         continue;
  457.         }
  458.         name = Tcl_GetHashKey(&iPtr->varFramePtr->varTable, hPtr);
  459.         if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) {
  460.         continue;
  461.         }
  462.         Tcl_AppendElement(interp, name, 0);
  463.     }
  464.     return TCL_OK;
  465.     } else if ((c == 'p') && (strncmp(argv[1], "procs", length)) == 0) {
  466.     if (argc > 3) {
  467.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  468.             " procs [pattern]\"", (char *) NULL);
  469.         return TCL_ERROR;
  470.     }
  471.     for (hPtr = Tcl_FirstHashEntry(&iPtr->commandTable, &search);
  472.         hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
  473.         char *name = Tcl_GetHashKey(&iPtr->commandTable, hPtr);
  474.  
  475.         cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
  476.         if (!TclIsProc(cmdPtr)) {
  477.         continue;
  478.         }
  479.         if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) {
  480.         continue;
  481.         }
  482.         Tcl_AppendElement(interp, name, 0);
  483.     }
  484.     return TCL_OK;
  485.     } else if ((c == 's') && (strncmp(argv[1], "script", length) == 0)) {
  486.     if (argc != 2) {
  487.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  488.             argv[0], " script\"", (char *) NULL);
  489.         return TCL_ERROR;
  490.     }
  491.     if (iPtr->scriptFile != NULL) {
  492.         interp->result = iPtr->scriptFile;
  493.     }
  494.     return TCL_OK;
  495.     } else if ((c == 't') && (strncmp(argv[1], "tclversion", length) == 0)) {
  496.     if (argc != 2) {
  497.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  498.             argv[0], " tclversion\"", (char *) NULL);
  499.         return TCL_ERROR;
  500.     }
  501.  
  502.     /*
  503.      * Note:  TCL_VERSION below is expected to be set with a "-D"
  504.      * switch in the Makefile.
  505.      */
  506.  
  507.     strcpy(iPtr->result, TCL_VERSION);
  508.     return TCL_OK;
  509.     } else if ((c == 'v') && (strncmp(argv[1], "vars", length)) == 0) {
  510.     Tcl_HashTable *tablePtr;
  511.     char *name;
  512.  
  513.     if (argc > 3) {
  514.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  515.             argv[0], " vars [pattern]\"", (char *) NULL);
  516.         return TCL_ERROR;
  517.     }
  518.     if (iPtr->varFramePtr == NULL) {
  519.         tablePtr = &iPtr->globalTable;
  520.     } else {
  521.         tablePtr = &iPtr->varFramePtr->varTable;
  522.     }
  523.     for (hPtr = Tcl_FirstHashEntry(tablePtr, &search);
  524.         hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
  525.         varPtr = (Var *) Tcl_GetHashValue(hPtr);
  526.         if (varPtr->flags & VAR_UNDEFINED) {
  527.         continue;
  528.         }
  529.         name = Tcl_GetHashKey(tablePtr, hPtr);
  530.         if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) {
  531.         continue;
  532.         }
  533.         Tcl_AppendElement(interp, name, 0);
  534.     }
  535.     return TCL_OK;
  536.     } else {
  537.     Tcl_AppendResult(interp, "bad option \"", argv[1],
  538.         "\": should be args, body, commands, cmdcount, default, ",
  539.         "exists, globals, level, library, locals, procs, ",
  540.         "script, tclversion, or vars",
  541.         (char *) NULL);
  542.     return TCL_ERROR;
  543.     }
  544. }
  545.  
  546. /*
  547.  *----------------------------------------------------------------------
  548.  *
  549.  * Tcl_JoinCmd --
  550.  *
  551.  *    This procedure is invoked to process the "join" Tcl command.
  552.  *    See the user documentation for details on what it does.
  553.  *
  554.  * Results:
  555.  *    A standard Tcl result.
  556.  *
  557.  * Side effects:
  558.  *    See the user documentation.
  559.  *
  560.  *----------------------------------------------------------------------
  561.  */
  562.  
  563.     /* ARGSUSED */
  564. int
  565. Tcl_JoinCmd(dummy, interp, argc, argv)
  566.     ClientData dummy;            /* Not used. */
  567.     Tcl_Interp *interp;            /* Current interpreter. */
  568.     int argc;                /* Number of arguments. */
  569.     char **argv;            /* Argument strings. */
  570. {
  571.     char *joinString;
  572.     char **listArgv;
  573.     int listArgc, i;
  574.  
  575.     if (argc == 2) {
  576.     joinString = " ";
  577.     } else if (argc == 3) {
  578.     joinString = argv[2];
  579.     } else {
  580.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  581.         " list ?joinString?\"", (char *) NULL);
  582.     return TCL_ERROR;
  583.     }
  584.  
  585.     if (Tcl_SplitList(interp, argv[1], &listArgc, &listArgv) != TCL_OK) {
  586.     return TCL_ERROR;
  587.     }
  588.     for (i = 0; i < listArgc; i++) {
  589.     if (i == 0) {
  590.         Tcl_AppendResult(interp, listArgv[0], (char *) NULL);
  591.     } else  {
  592.         Tcl_AppendResult(interp, joinString, listArgv[i], (char *) NULL);
  593.     }
  594.     }
  595.     ckfree((char *) listArgv);
  596.     return TCL_OK;
  597. }
  598.  
  599. /*
  600.  *----------------------------------------------------------------------
  601.  *
  602.  * Tcl_LindexCmd --
  603.  *
  604.  *    This procedure is invoked to process the "lindex" Tcl command.
  605.  *    See the user documentation for details on what it does.
  606.  *
  607.  * Results:
  608.  *    A standard Tcl result.
  609.  *
  610.  * Side effects:
  611.  *    See the user documentation.
  612.  *
  613.  *----------------------------------------------------------------------
  614.  */
  615.  
  616.     /* ARGSUSED */
  617. int
  618. Tcl_LindexCmd(dummy, interp, argc, argv)
  619.     ClientData dummy;            /* Not used. */
  620.     Tcl_Interp *interp;            /* Current interpreter. */
  621.     int argc;                /* Number of arguments. */
  622.     char **argv;            /* Argument strings. */
  623. {
  624.     char *p, *element;
  625.     int index, size, parenthesized, result;
  626.  
  627.     if (argc != 3) {
  628.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  629.         " list index\"", (char *) NULL);
  630.     return TCL_ERROR;
  631.     }
  632.     if (Tcl_GetInt(interp, argv[2], &index) != TCL_OK) {
  633.     return TCL_ERROR;
  634.     }
  635.     if (index < 0) {
  636.     return TCL_OK;
  637.     }
  638.     for (p = argv[1] ; index >= 0; index--) {
  639.     result = TclFindElement(interp, p, &element, &p, &size,
  640.         &parenthesized);
  641.     if (result != TCL_OK) {
  642.         return result;
  643.     }
  644.     }
  645.     if (size == 0) {
  646.     return TCL_OK;
  647.     }
  648.     if (size >= TCL_RESULT_SIZE) {
  649.     interp->result = (char *) ckalloc((unsigned) size+1);
  650.     interp->freeProc = (Tcl_FreeProc *) free;
  651.     }
  652.     if (parenthesized) {
  653.     memcpy((VOID *) interp->result, (VOID *) element, size);
  654.     interp->result[size] = 0;
  655.     } else {
  656.     TclCopyAndCollapse(size, element, interp->result);
  657.     }
  658.     return TCL_OK;
  659. }
  660.  
  661. /*
  662.  *----------------------------------------------------------------------
  663.  *
  664.  * Tcl_LinsertCmd --
  665.  *
  666.  *    This procedure is invoked to process the "linsert" Tcl command.
  667.  *    See the user documentation for details on what it does.
  668.  *
  669.  * Results:
  670.  *    A standard Tcl result.
  671.  *
  672.  * Side effects:
  673.  *    See the user documentation.
  674.  *
  675.  *----------------------------------------------------------------------
  676.  */
  677.  
  678.     /* ARGSUSED */
  679. int
  680. Tcl_LinsertCmd(dummy, interp, argc, argv)
  681.     ClientData dummy;            /* Not used. */
  682.     Tcl_Interp *interp;            /* Current interpreter. */
  683.     int argc;                /* Number of arguments. */
  684.     char **argv;            /* Argument strings. */
  685. {
  686.     char *p, *element, savedChar;
  687.     int i, index, count, result, size, brace;
  688.  
  689.     if (argc < 4) {
  690.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  691.         " list index element ?element ...?\"", (char *) NULL);
  692.     return TCL_ERROR;
  693.     }
  694.     if (Tcl_GetInt(interp, argv[2], &index) != TCL_OK) {
  695.     return TCL_ERROR;
  696.     }
  697.  
  698.     /*
  699.      * Skip over the first "index" elements of the list, then add
  700.      * all of those elements to the result.
  701.      */
  702.  
  703.     size = 0;
  704.     brace = 0;
  705.     element = argv[1];
  706.     for (count = 0, p = argv[1]; (count < index) && (*p != 0); count++) {
  707.     result = TclFindElement(interp, p, &element, &p, &size, &brace);
  708.     if (result != TCL_OK) {
  709.         return result;
  710.     }
  711.     }
  712.     if (*p == 0) {
  713.     Tcl_AppendResult(interp, argv[1], (char *) NULL);
  714.     } else {
  715.     char *end;
  716.  
  717.     end = element+size;
  718.     if (brace) {
  719.         end++;
  720.     }
  721.     savedChar = *end;
  722.     *end = 0;
  723.     Tcl_AppendResult(interp, argv[1], (char *) NULL);
  724.     *end = savedChar;
  725.     }
  726.  
  727.     /*
  728.      * Add the new list elements.
  729.      */
  730.  
  731.     for (i = 3; i < argc; i++) {
  732.     Tcl_AppendElement(interp, argv[i], 0);
  733.     }
  734.  
  735.     /*
  736.      * Append the remainder of the original list.
  737.      */
  738.  
  739.     if (*p != 0) {
  740.     Tcl_AppendResult(interp, " ", p, (char *) NULL);
  741.     }
  742.     return TCL_OK;
  743. }
  744.  
  745. /*
  746.  *----------------------------------------------------------------------
  747.  *
  748.  * Tcl_ListCmd --
  749.  *
  750.  *    This procedure is invoked to process the "list" Tcl command.
  751.  *    See the user documentation for details on what it does.
  752.  *
  753.  * Results:
  754.  *    A standard Tcl result.
  755.  *
  756.  * Side effects:
  757.  *    See the user documentation.
  758.  *
  759.  *----------------------------------------------------------------------
  760.  */
  761.  
  762.     /* ARGSUSED */
  763. int
  764. Tcl_ListCmd(dummy, interp, argc, argv)
  765.     ClientData dummy;            /* Not used. */
  766.     Tcl_Interp *interp;            /* Current interpreter. */
  767.     int argc;                /* Number of arguments. */
  768.     char **argv;            /* Argument strings. */
  769. {
  770.     if (argc < 2) {
  771.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  772.         " arg ?arg ...?\"", (char *) NULL);
  773.     return TCL_ERROR;
  774.     }
  775.     interp->result = Tcl_Merge(argc-1, argv+1);
  776.     interp->freeProc = (Tcl_FreeProc *) free;
  777.     return TCL_OK;
  778. }
  779.  
  780. /*
  781.  *----------------------------------------------------------------------
  782.  *
  783.  * Tcl_LlengthCmd --
  784.  *
  785.  *    This procedure is invoked to process the "llength" Tcl command.
  786.  *    See the user documentation for details on what it does.
  787.  *
  788.  * Results:
  789.  *    A standard Tcl result.
  790.  *
  791.  * Side effects:
  792.  *    See the user documentation.
  793.  *
  794.  *----------------------------------------------------------------------
  795.  */
  796.  
  797.     /* ARGSUSED */
  798. int
  799. Tcl_LlengthCmd(dummy, interp, argc, argv)
  800.     ClientData dummy;            /* Not used. */
  801.     Tcl_Interp *interp;            /* Current interpreter. */
  802.     int argc;                /* Number of arguments. */
  803.     char **argv;            /* Argument strings. */
  804. {
  805.     int count, result;
  806.     char *element, *p;
  807.  
  808.     if (argc != 2) {
  809.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  810.         " list\"", (char *) NULL);
  811.     return TCL_ERROR;
  812.     }
  813.     for (count = 0, p = argv[1]; *p != 0 ; count++) {
  814.     result = TclFindElement(interp, p, &element, &p, (int *) NULL,
  815.         (int *) NULL);
  816.     if (result != TCL_OK) {
  817.         return result;
  818.     }
  819.     if (*element == 0) {
  820.         break;
  821.     }
  822.     }
  823.     sprintf(interp->result, "%d", count);
  824.     return TCL_OK;
  825. }
  826.  
  827. /*
  828.  *----------------------------------------------------------------------
  829.  *
  830.  * Tcl_LrangeCmd --
  831.  *
  832.  *    This procedure is invoked to process the "lrange" Tcl command.
  833.  *    See the user documentation for details on what it does.
  834.  *
  835.  * Results:
  836.  *    A standard Tcl result.
  837.  *
  838.  * Side effects:
  839.  *    See the user documentation.
  840.  *
  841.  *----------------------------------------------------------------------
  842.  */
  843.  
  844.     /* ARGSUSED */
  845. int
  846. Tcl_LrangeCmd(notUsed, interp, argc, argv)
  847.     ClientData notUsed;            /* Not used. */
  848.     Tcl_Interp *interp;            /* Current interpreter. */
  849.     int argc;                /* Number of arguments. */
  850.     char **argv;            /* Argument strings. */
  851. {
  852.     int first, last, result;
  853.     char *begin, *end, c, *dummy;
  854.     int count;
  855.  
  856.     if (argc != 4) {
  857.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  858.         " list first last\"", (char *) NULL);
  859.     return TCL_ERROR;
  860.     }
  861.     if (Tcl_GetInt(interp, argv[2], &first) != TCL_OK) {
  862.     return TCL_ERROR;
  863.     }
  864.     if (first < 0) {
  865.     first = 0;
  866.     }
  867.     if ((*argv[3] == 'e') && (strncmp(argv[3], "end", strlen(argv[3])) == 0)) {
  868.     last = 1000000;
  869.     } else {
  870.     if (Tcl_GetInt(interp, argv[3], &last) != TCL_OK) {
  871.         Tcl_ResetResult(interp);
  872.         Tcl_AppendResult(interp,
  873.             "expected integer or \"end\" but got \"",
  874.             argv[3], "\"", (char *) NULL);
  875.         return TCL_ERROR;
  876.     }
  877.     }
  878.     if (first > last) {
  879.     return TCL_OK;
  880.     }
  881.  
  882.     /*
  883.      * Extract a range of fields.
  884.      */
  885.  
  886.     for (count = 0, begin = argv[1]; count < first; count++) {
  887.     result = TclFindElement(interp, begin, &dummy, &begin, (int *) NULL,
  888.         (int *) NULL);
  889.     if (result != TCL_OK) {
  890.         return result;
  891.     }
  892.     if (*begin == 0) {
  893.         break;
  894.     }
  895.     }
  896.     for (count = first, end = begin; (count <= last) && (*end != 0);
  897.         count++) {
  898.     result = TclFindElement(interp, end, &dummy, &end, (int *) NULL,
  899.         (int *) NULL);
  900.     if (result != TCL_OK) {
  901.         return result;
  902.     }
  903.     }
  904.  
  905.     /*
  906.      * Chop off trailing spaces.
  907.      */
  908.  
  909.     while (isspace(end[-1])) {
  910.     end--;
  911.     }
  912.     c = *end;
  913.     *end = 0;
  914.     Tcl_SetResult(interp, begin, TCL_VOLATILE);
  915.     *end = c;
  916.     return TCL_OK;
  917. }
  918.  
  919. /*
  920.  *----------------------------------------------------------------------
  921.  *
  922.  * Tcl_LreplaceCmd --
  923.  *
  924.  *    This procedure is invoked to process the "lreplace" Tcl command.
  925.  *    See the user documentation for details on what it does.
  926.  *
  927.  * Results:
  928.  *    A standard Tcl result.
  929.  *
  930.  * Side effects:
  931.  *    See the user documentation.
  932.  *
  933.  *----------------------------------------------------------------------
  934.  */
  935.  
  936.     /* ARGSUSED */
  937. int
  938. Tcl_LreplaceCmd(notUsed, interp, argc, argv)
  939.     ClientData notUsed;            /* Not used. */
  940.     Tcl_Interp *interp;            /* Current interpreter. */
  941.     int argc;                /* Number of arguments. */
  942.     char **argv;            /* Argument strings. */
  943. {
  944.     char *p1, *p2, *element, savedChar, *dummy;
  945.     int i, first, last, count, result, size, brace;
  946.  
  947.     if (argc < 4) {
  948.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  949.         " list first last ?element element ...?\"", (char *) NULL);
  950.     return TCL_ERROR;
  951.     }
  952.     if (Tcl_GetInt(interp, argv[2], &first) != TCL_OK) {
  953.     return TCL_ERROR;
  954.     }
  955.     if (TclGetListIndex(interp, argv[3], &last) != TCL_OK) {
  956.     return TCL_ERROR;
  957.     }
  958.     if (first < 0) {
  959.     first = 0;
  960.     }
  961.     if (last < 0) {
  962.     last = 0;
  963.     }
  964.     if (first > last) {
  965.     Tcl_AppendResult(interp, "first index must not be greater than second",
  966.         (char *) NULL);
  967.     return TCL_ERROR;
  968.     }
  969.  
  970.     /*
  971.      * Skip over the elements of the list before "first".
  972.      */
  973.  
  974.     size = 0;
  975.     brace = 0;
  976.     element = argv[1];
  977.     for (count = 0, p1 = argv[1]; (count < first) && (*p1 != 0); count++) {
  978.     result = TclFindElement(interp, p1, &element, &p1, &size, &brace);
  979.     if (result != TCL_OK) {
  980.         return result;
  981.     }
  982.     }
  983.     if (*p1 == 0) {
  984.     Tcl_AppendResult(interp, "list doesn't contain element ",
  985.         argv[2], (char *) NULL);
  986.     return TCL_ERROR;
  987.     }
  988.  
  989.     /*
  990.      * Skip over the elements of the list up through "last".
  991.      */
  992.  
  993.     for (p2 = p1 ; (count <= last) && (*p2 != 0); count++) {
  994.     result = TclFindElement(interp, p2, &dummy, &p2, (int *) NULL,
  995.         (int *) NULL);
  996.     if (result != TCL_OK) {
  997.         return result;
  998.     }
  999.     }
  1000.  
  1001.     /*
  1002.      * Add the elements up through "first" to the result.
  1003.      */
  1004.  
  1005.     p1 = element+size;
  1006.     if (brace) {
  1007.     p1++;
  1008.     }
  1009.     savedChar = *p1;
  1010.     *p1 = 0;
  1011.     Tcl_AppendResult(interp, argv[1], (char *) NULL);
  1012.     *p1 = savedChar;
  1013.  
  1014.     /*
  1015.      * Add the new list elements.
  1016.      */
  1017.  
  1018.     for (i = 4; i < argc; i++) {
  1019.     Tcl_AppendElement(interp, argv[i], 0);
  1020.     }
  1021.  
  1022.     /*
  1023.      * Append the remainder of the original list.
  1024.      */
  1025.  
  1026.     if (*p2 != 0) {
  1027.     if (*interp->result == 0) {
  1028.         Tcl_SetResult(interp, p2, TCL_VOLATILE);
  1029.     } else {
  1030.         Tcl_AppendResult(interp, " ", p2, (char *) NULL);
  1031.     }
  1032.     }
  1033.     return TCL_OK;
  1034. }
  1035.  
  1036. /*
  1037.  *----------------------------------------------------------------------
  1038.  *
  1039.  * Tcl_LsearchCmd --
  1040.  *
  1041.  *    This procedure is invoked to process the "lsearch" Tcl command.
  1042.  *    See the user documentation for details on what it does.
  1043.  *
  1044.  * Results:
  1045.  *    A standard Tcl result.
  1046.  *
  1047.  * Side effects:
  1048.  *    See the user documentation.
  1049.  *
  1050.  *----------------------------------------------------------------------
  1051.  */
  1052.  
  1053.     /* ARGSUSED */
  1054. int
  1055. Tcl_LsearchCmd(notUsed, interp, argc, argv)
  1056.     ClientData notUsed;            /* Not used. */
  1057.     Tcl_Interp *interp;            /* Current interpreter. */
  1058.     int argc;                /* Number of arguments. */
  1059.     char **argv;            /* Argument strings. */
  1060. {
  1061.     int listArgc;
  1062.     char **listArgv;
  1063.     int i, match;
  1064.  
  1065.     if (argc != 3) {
  1066.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1067.         " list pattern\"", (char *) NULL);
  1068.     return TCL_ERROR;
  1069.     }
  1070.     if (Tcl_SplitList(interp, argv[1], &listArgc, &listArgv) != TCL_OK) {
  1071.     return TCL_ERROR;
  1072.     }
  1073.     match = -1;
  1074.     for (i = 0; i < listArgc; i++) {
  1075.     if (Tcl_StringMatch(listArgv[i], argv[2])) {
  1076.         match = i;
  1077.         break;
  1078.     }
  1079.     }
  1080.     sprintf(interp->result, "%d", match);
  1081.     ckfree((char *) listArgv);
  1082.     return TCL_OK;
  1083. }
  1084.  
  1085. /*
  1086.  *----------------------------------------------------------------------
  1087.  *
  1088.  * Tcl_LsortCmd --
  1089.  *
  1090.  *    This procedure is invoked to process the "lsort" Tcl command.
  1091.  *    See the user documentation for details on what it does.
  1092.  *
  1093.  * Results:
  1094.  *    A standard Tcl result.
  1095.  *
  1096.  * Side effects:
  1097.  *    See the user documentation.
  1098.  *
  1099.  *----------------------------------------------------------------------
  1100.  */
  1101.  
  1102.     /* ARGSUSED */
  1103. int
  1104. Tcl_LsortCmd(notUsed, interp, argc, argv)
  1105.     ClientData notUsed;            /* Not used. */
  1106.     Tcl_Interp *interp;            /* Current interpreter. */
  1107.     int argc;                /* Number of arguments. */
  1108.     char **argv;            /* Argument strings. */
  1109. {
  1110.     int listArgc;
  1111.     char **listArgv;
  1112.  
  1113.     if (argc != 2) {
  1114.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1115.         " list\"", (char *) NULL);
  1116.     return TCL_ERROR;
  1117.     }
  1118.     if (Tcl_SplitList(interp, argv[1], &listArgc, &listArgv) != TCL_OK) {
  1119.     return TCL_ERROR;
  1120.     }
  1121.     qsort((VOID *) listArgv, listArgc, sizeof (char *), SortCompareProc);
  1122.     interp->result = Tcl_Merge(listArgc, listArgv);
  1123.     interp->freeProc = (Tcl_FreeProc *) free;
  1124.     ckfree((char *) listArgv);
  1125.     return TCL_OK;
  1126. }
  1127.  
  1128. /*
  1129.  * The procedure below is called back by qsort to determine
  1130.  * the proper ordering between two elements.
  1131.  */
  1132.  
  1133. static int
  1134. SortCompareProc(first, second)
  1135.     CONST VOID *first, *second;        /* Elements to be compared. */
  1136. {
  1137.     return strcmp(*((char **) first), *((char **) second));
  1138. }
  1139.